Workbench Add-On/Workbench Add-On - Volume 1.iso/BBS-Archive/Dev/Obrn-A_1.6_lib.lha/oberon-a/source3.lha/source/framework/Events.mod

Text File | 1995-06-29 | 14KB | 626 lines

(*************************************************************************

     $RCSfile: Events.mod $
  Description: Implements classes for managing events

   Created by: fjc (Frank Copeland)
    $Revision: 1.15 $
      $Author: fjc $
        $Date: 1995/06/21 17:03:01 $

  Copyright © 1994-1995, Frank Copeland.
  Improvements and corrections by Helmuth Ritzer.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

*************************************************************************)

<*  STANDARD- *> (* Non-portable code is allowed *)
<*$ NilChk- *>

(*
** NIL checking is assumed to be disabled, and procedures make explicit
** checks for NIL pointers using ASSERT().
*)

MODULE Events;

IMPORT
  SYS := SYSTEM, Kernel, e := Exec, es := ExecSupport, i := Intuition,
  gt := GadTools;


TYPE

  Signal *= POINTER TO SignalRec;
  SignalRec *= RECORD
    sigBit *: SHORTINT;
  END; (* SignalRec *)


CONST
  Pass     *= 0;
  Continue *= 1;
  Stop     *= 2;
  StopAll  *= 3;

  NoGC *= 0;       (* Turn off garbage collection *)

TYPE

  MessagePort *= POINTER TO MessagePortRec;
  MessagePortRec *= RECORD (SignalRec)
    port -: e.MsgPortPtr;
  END; (* MessagePortRec *)


TYPE

  IdcmpPort *= POINTER TO IdcmpPortRec;
  IdcmpPortRec * = RECORD (MessagePortRec) END;


TYPE

  GadToolsPort *= POINTER TO GadToolsPortRec;
  GadToolsPortRec *= RECORD (IdcmpPortRec) END;


CONST

  NumSignals = 32; (* The maximum number of signals for a Task. *)


TYPE

  EventLoop *= POINTER TO EventLoopRec;
  EventLoopRec *= RECORD
    sigBits      : SET;
    signal       : ARRAY NumSignals OF Signal;
    collectFreq,
    collectCount : INTEGER;
  END; (* EventLoopRec *)

VAR

  loops : EventLoop;

(*-----------------------------------*)
PROCEDURE (h : Signal) HandleSig * () : INTEGER;

BEGIN (* HandleSig *)
  HALT (99);
  RETURN StopAll
END HandleSig;


(*-----------------------------------*)
PROCEDURE SimpleLoop * ( sig : Signal; collectFreq : INTEGER );

  VAR signalsReceived : SET; result, collectCount : INTEGER;

BEGIN (* SimpleLoop *)
  ASSERT (sig # NIL, 97);
  ASSERT (collectFreq >= NoGC, 97);
  collectCount := collectFreq;
  REPEAT
    signalsReceived := e.Wait ({sig.sigBit});
    result := sig.HandleSig ();
    IF collectFreq # NoGC THEN
      IF collectCount = 1 THEN
        (* i.DisplayBeep (NIL); *)
        Kernel.GC;
        collectCount := collectFreq
      ELSE
        DEC (collectCount)
      END
    END
  UNTIL (result > Continue);
END SimpleLoop;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) HandleMsg * ( msg : e.MessagePtr ) : INTEGER;

BEGIN (* HandleMsg *)
  HALT (99);
  RETURN StopAll
END HandleMsg;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) HandleSig * () : INTEGER;

  VAR result : INTEGER; msg : e.MessagePtr;

BEGIN (* HandleSig *)
  result := Pass;
  LOOP
    msg := e.GetMsg (mp.port);
    IF msg = NIL THEN EXIT END;
    result := mp.HandleMsg (msg);
    IF result = Pass THEN e.ReplyMsg (msg) END;
    IF result > Continue THEN EXIT END
  END;
  RETURN result
END HandleSig;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) FlushPort * ();

  VAR msg : e.MessagePtr;

BEGIN (* FlushPort *)
  e.Forbid ();
    LOOP
      msg := e.GetMsg (mp.port);
      IF msg = NIL THEN EXIT END;
      e.ReplyMsg (msg)
    END;
  e.Permit ()
END FlushPort;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) AttachPort* ( port : e.MsgPortPtr );

BEGIN (* AttachPort *)
  ASSERT (port # NIL, 97);
  mp.sigBit := port.sigBit;
  mp.port := port;
END AttachPort;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) DetachPort *;

BEGIN (* DetachPort *)
  mp.FlushPort ();
  mp.port := NIL;
  mp.sigBit := -1;
END DetachPort;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) MakePort *
  ( name : ARRAY OF CHAR; priority : SHORTINT )
  : BOOLEAN;

  VAR port : e.MsgPortPtr;

<*$CopyArrays-*>
BEGIN (* MakePort *)
  port := es.CreatePort (name, priority);
  IF port # NIL THEN mp.AttachPort (port); RETURN TRUE
  ELSE RETURN FALSE
  END
END MakePort;


(*-----------------------------------*)
PROCEDURE (mp : MessagePort) DeletePort *;

BEGIN (* DeletePort *)
  e.Forbid ();
    mp.FlushPort ();
    es.DeletePort (mp.port);
  e.Permit ();
  mp.port := NIL;
  mp.sigBit := -1
END DeletePort;


(*-----------------------------------*)

<*$ < ReturnChk- *>

PROCEDURE (ip : IdcmpPort) DefaultHandler *
  ( msg : i.IntuiMessagePtr; flag : INTEGER )
  : INTEGER;

BEGIN (* DefaultHandler *)
  HALT (99);
  RETURN Pass
END DefaultHandler;

PROCEDURE (ip : IdcmpPort) HandleSizeVerify *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleSizeVerify *)
  RETURN Pass
END HandleSizeVerify;

PROCEDURE (ip : IdcmpPort) HandleNewSize *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleNewSize *)
  RETURN Pass
END HandleNewSize;

PROCEDURE (ip : IdcmpPort) HandleRefreshWindow *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleRefreshWindow *)
  RETURN Pass
END HandleRefreshWindow;

PROCEDURE (ip : IdcmpPort) HandleMouseButtons *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleMouseButtons *)
  RETURN Pass
END HandleMouseButtons;

PROCEDURE (ip : IdcmpPort) HandleMouseMove *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleMouseMove *)
  RETURN Pass
END HandleMouseMove;

PROCEDURE (ip : IdcmpPort) HandleGadgetDown *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleGadgetDown *)
  RETURN Pass
END HandleGadgetDown;

PROCEDURE (ip : IdcmpPort) HandleGadgetUp *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleGadgetUp *)
  RETURN Pass
END HandleGadgetUp;

PROCEDURE (ip : IdcmpPort) HandleReqSet *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleReqSet *)
  RETURN Pass
END HandleReqSet;

PROCEDURE (ip : IdcmpPort) HandleMenuPick *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleMenuPick *)
  RETURN Pass
END HandleMenuPick;

PROCEDURE (ip : IdcmpPort) HandleCloseWindow *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleCloseWindow *)
  RETURN Pass
END HandleCloseWindow;

PROCEDURE (ip : IdcmpPort) HandleRawKey *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleRawKey *)
  RETURN Pass
END HandleRawKey;

PROCEDURE (ip : IdcmpPort) HandleReqVerify *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleReqVerify *)
  RETURN Pass
END HandleReqVerify;

PROCEDURE (ip : IdcmpPort) HandleReqClear *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleReqClear *)
  RETURN Pass
END HandleReqClear;

PROCEDURE (ip : IdcmpPort) HandleMenuVerify *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleMenuVerify *)
  RETURN Pass
END HandleMenuVerify;

PROCEDURE (ip : IdcmpPort) HandleNewPrefs *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleNewPrefs *)
  RETURN Pass
END HandleNewPrefs;

PROCEDURE (ip : IdcmpPort) HandleDiskInserted *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleDiskInserted *)
  RETURN Pass
END HandleDiskInserted;

PROCEDURE (ip : IdcmpPort) HandleDiskRemoved *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleDiskRemoved *)
  RETURN Pass
END HandleDiskRemoved;

PROCEDURE (ip : IdcmpPort) HandleActiveWindow *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleActiveWindow *)
  RETURN Pass
END HandleActiveWindow;

PROCEDURE (ip : IdcmpPort) HandleInactiveWindow *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleInactiveWindow *)
  RETURN Pass
END HandleInactiveWindow;

PROCEDURE (ip : IdcmpPort) HandleDeltaMove *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleDeltaMove *)
  RETURN Pass
END HandleDeltaMove;

PROCEDURE (ip : IdcmpPort) HandleVanillaKey *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleVanillaKey *)
  RETURN Pass
END HandleVanillaKey;

PROCEDURE (ip : IdcmpPort) HandleIntuiTicks *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleIntuiTicks *)
  RETURN Pass
END HandleIntuiTicks;

PROCEDURE (ip : IdcmpPort) HandleIdcmpUpdate *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleIdcmpUpdate *)
  RETURN Pass
END HandleIdcmpUpdate;

PROCEDURE (ip : IdcmpPort) HandleMenuHelp *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleMenuHelp *)
  RETURN Pass
END HandleMenuHelp;

PROCEDURE (ip : IdcmpPort) HandleChangeWindow *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleChangeWindow *)
  RETURN Pass
END HandleChangeWindow;

PROCEDURE (ip : IdcmpPort) HandleGadgetHelp *
  ( msg : i.IntuiMessagePtr )
  : INTEGER;

BEGIN (* HandleGadgetHelp *)
  RETURN Pass
END HandleGadgetHelp;

<*$ > *>


(*-----------------------------------*)
PROCEDURE (ip : IdcmpPort) HandleMsg* ( msg : e.MessagePtr ) : INTEGER;

  VAR
    intuiMessage : i.IntuiMessagePtr;
    class : SET; flag, result : INTEGER;

BEGIN (* HandleMsg *)
  intuiMessage := SYS.VAL (i.IntuiMessagePtr, msg);
  class := intuiMessage.class;
  flag := 0; WHILE (flag < 32) & ~(flag IN class) DO INC (flag) END;
  CASE flag OF
    i.sizeVerify     : result := ip.HandleSizeVerify (intuiMessage) |
    i.newSize        : result := ip.HandleNewSize (intuiMessage) |
    i.refreshWindow  : result := ip.HandleRefreshWindow (intuiMessage) |
    i.mouseButtons   : result := ip.HandleMouseButtons (intuiMessage) |
    i.mouseMove      : result := ip.HandleMouseMove (intuiMessage) |
    i.gadgetDown     : result := ip.HandleGadgetDown (intuiMessage) |
    i.gadgetUp       : result := ip.HandleGadgetUp (intuiMessage) |
    i.reqSet         : result := ip.HandleReqSet (intuiMessage) |
    i.menuPick       : result := ip.HandleMenuPick (intuiMessage) |
    i.closeWindow    : result := ip.HandleCloseWindow (intuiMessage) |
    i.rawKey         : result := ip.HandleRawKey (intuiMessage) |
    i.reqVerify      : result := ip.HandleReqVerify (intuiMessage) |
    i.reqClear       : result := ip.HandleReqClear (intuiMessage) |
    i.menuVerify     : result := ip.HandleMenuVerify (intuiMessage) |
    i.newPrefs       : result := ip.HandleNewPrefs (intuiMessage) |
    i.diskInserted   : result := ip.HandleDiskInserted (intuiMessage) |
    i.diskRemoved    : result := ip.HandleDiskRemoved (intuiMessage) |
    i.activeWindow   : result := ip.HandleActiveWindow (intuiMessage) |
    i.inactiveWindow : result := ip.HandleInactiveWindow (intuiMessage) |
    i.deltaMove      : result := ip.HandleDeltaMove (intuiMessage) |
    i.vanillaKey     : result := ip.HandleVanillaKey (intuiMessage) |
    i.intuiTicks     : result := ip.HandleIntuiTicks (intuiMessage) |
    i.idcmpUpdate    : result := ip.HandleIdcmpUpdate (intuiMessage) |
    i.menuHelp       : result := ip.HandleMenuHelp (intuiMessage) |
    i.changeWindow   : result := ip.HandleChangeWindow (intuiMessage) |
    i.gadgetHelp     : result := ip.HandleGadgetHelp (intuiMessage) |
  ELSE result := ip.DefaultHandler (intuiMessage, flag)
  END;
  RETURN result
END HandleMsg;


(*-----------------------------------*)
PROCEDURE (ip : IdcmpPort) SetupWindow* (window : i.WindowPtr);

BEGIN (* SetupWindow *)
END SetupWindow;


(*-----------------------------------*)
PROCEDURE (ip : IdcmpPort) CleanupWindow* (window : i.WindowPtr);

BEGIN (* CleanupWindow *)
END CleanupWindow;


(*-----------------------------------*)
PROCEDURE (gtp : GadToolsPort) HandleSig * () : INTEGER;

  VAR result : INTEGER; msg : i.IntuiMessagePtr;

BEGIN (* HandleSig *)
  result := Pass;
  ASSERT (gtp.port # NIL, 97);
  LOOP
    msg := gt.GetIMsg (gtp.port);
    IF msg = NIL THEN EXIT END;
    result := gtp.HandleMsg (SYS.VAL (e.MessagePtr, msg));
    IF result = Pass THEN gt.ReplyIMsg (msg) END;
    IF result > Continue THEN EXIT END
  END;
  RETURN result
END HandleSig;


(*-----------------------------------*)
PROCEDURE (gtp : GadToolsPort) FlushPort * ();

  VAR msg : i.IntuiMessagePtr;

BEGIN (* FlushPort *)
  ASSERT (gtp.port # NIL, 97);
  e.Forbid ();
    LOOP
      msg := gt.GetIMsg (gtp.port);
      IF msg = NIL THEN EXIT END;
      gt.ReplyIMsg (msg)
    END;
  e.Permit ()
END FlushPort;


(*-----------------------------------*)
PROCEDURE InitEventLoop* ( el : EventLoop );

  VAR index : INTEGER;

BEGIN (* InitEventLoop *)
  ASSERT (el # NIL, 97);
  el.sigBits := {};
  FOR index := 0 TO NumSignals - 1 DO
    el.signal [index] := NIL
  END;
  el.collectFreq := NoGC;
END InitEventLoop;


(*-----------------------------------*)
PROCEDURE (el: EventLoop) AddSignal* ( signal : Signal ) : Signal;

  VAR sigBit : SHORTINT; oldSignal : Signal;

BEGIN (* AddSignal *)
  ASSERT (el # NIL, 97);
  ASSERT (signal # NIL, 97);
  sigBit := signal.sigBit;
  oldSignal := el.signal [sigBit];
  INCL (el.sigBits, sigBit);
  el.signal [sigBit] := signal;
  RETURN oldSignal
END AddSignal;


(*-----------------------------------*)
PROCEDURE (el: EventLoop) RemoveSignal* ( signal : Signal );

  VAR sigBit : SHORTINT;

BEGIN (* RemoveSignal *)
  ASSERT (el # NIL, 97);
  ASSERT (signal # NIL, 97);
  sigBit := signal.sigBit;
  IF el.signal [sigBit] = signal THEN
    el.signal [sigBit] := NIL;
    EXCL (el.sigBits, sigBit);
  END
END RemoveSignal;


(*-----------------------------------*)
PROCEDURE (el: EventLoop) Collect* ( collectFreq : INTEGER );

BEGIN (* Collect *)
  ASSERT (collectFreq >= NoGC, 97);
  el.collectFreq := collectFreq;
  el.collectCount := collectFreq;
END Collect;


(*-----------------------------------*)
PROCEDURE (el : EventLoop) Do*;

  VAR
    signalsReceived : SET; sigBit : SHORTINT; result : INTEGER;
    signal : Signal;

BEGIN (* Loop *)
  ASSERT (el # NIL, 97);
  WHILE el.sigBits # {} DO
    signalsReceived := e.Wait (el.sigBits);
    FOR sigBit := 0 TO NumSignals - 1 DO
      IF sigBit IN signalsReceived THEN
        signal := el.signal [sigBit];
        ASSERT (signal # NIL, 97);
        result := signal.HandleSig ();
        IF result = Stop THEN
          el.signal [sigBit] := NIL;
          EXCL (el.sigBits, sigBit)
        ELSIF result = StopAll THEN
          el.sigBits := {}
        END
      END
    END;
    IF el.collectFreq # NoGC THEN
      IF el.collectCount = 1 THEN
        (* i.DisplayBeep (NIL); *)
        Kernel.GC;
        el.collectCount := el.collectFreq
      ELSE
        DEC (el.collectCount)
      END
    END;
  END
END Do;

END Events.